COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	∂19-Nov-83  2201	RPG  	Blocks   
C00005 00003	(eval-when (compile) (fasload struct fas dsk (mac lsp)))
C00009 00004	(defun construct (s structure)
C00014 00005	(fasload block2)
C00018 ENDMK
C⊗;
∂19-Nov-83  2201	RPG  	Blocks   
I looked at BLOCK2.LSP[F83,JMC] and decided that the programming
style per se was pretty modern as it was. If, however, you want to
include as `style' the overall solution, then it has to be completely
re-written, and the modern style is not as concise as what you have.

To be more specific, look at BLOCK2.LSP[1,RPG] in which I've defined
situation-plans, towers, etc abstractly (as macros in this case)
and then re-done the program using these macros. The effect is that
it is now easy to modify the underlying structure and it is easy to
understand the program. I also took the liberty of including the
on-table requirement, which also simpified the program by making it
more general (now there is no need to test for eq to TABLE and NULL).

The last page is the program being applied to some test cases in a
clearer setting than your test cases.

The new program is about 3 times as long due to the macros, but the
main program part is a little shorter.

The upshot is that you do have to pay a price for the ability to understand
what you're doing to be able to modify the code later.
			-rpg-

	Thanks for the modernization.  I trust it's ok to show it to
CS206.  However, while the modernization makes the data structure
abstract and hence easily modifiable, the algorithm is no more readily
modified than mine.  Notice, for example, block3.lsp[f83,jmc] which is
modified to place a block in final position instead of on the table.
Both your program and mine require adding the desired structure as an argument
to MOVE and CLEAR.  Moreover, in neither case is it clear what to do if we
decide to make moves opportunistically rather than simply indexing
through the towers of the structure.  I hope to have something more
flexible soon.
(eval-when (compile) (fasload struct fas dsk (mac lsp)))
(declare (mapex t))
(declare (fixsw t))

(defmacro empty-situation (situation)
	  `(null ,situation))

(defmacro make-sit-plan (situation plan)
	  `(cons ,situation ,plan))

(defmacro situation (sit-plan)
	  `(car ,sit-plan))

(defmacro plan (sit-plan)
	  `(cdr ,sit-plan))

(defmacro make-structure towers
	  `(list . ,towers))

(defmacro make-tower blocks
      `(list ,@blocks 'table))

(defmacro first-tower (structure)
	  `(car ,structure))

(defmacro other-towers (structure)
	  `(cdr ,structure))

(defmacro empty-structure (structure)
	  `(null ,structure))

(defmacro empty-tower (tower)
	  `(null ,tower))

(defmacro top-block (blocks)
	  `(car ,blocks))

(defmacro bottom-blocks (blocks)
	  `(cdr ,blocks))

(defmacro bottom-block (tower)
	  `(car (last ,tower)))

(defmacro add-bottom-block (block tower)
	  `(nconc ,tower (ncons ,block)))

(defmacro reverse-tower (tower)
	  `(reverse ,tower))

(defmacro add-block (block tower)
	  `(cons ,block ,tower))

(defmacro remove-block (tower)
	  `(cdr ,tower))

(defmacro make-step (block location)
	  `(list ,block ,location))

(defmacro location (step)
	  `(cadr ,step))

(defmacro block (step)
	  `(car ,step))

(defmacro add-plan (step sit-plan)
	  `(setf (plan ,sit-plan)
		 `(,,step .,(plan ,sit-plan))))

(defmacro tablep (block)
	  `(eq ,block 'table))

(defmacro add-tower (tower towers)
	  `(cons ,tower ,towers))

(defmacro table-only (tower)
	  `(and (= (length ,tower) 1)
		(eq (top-block ,tower) 'table)))

(defmacro goal towers
	  `(make-structure
	    .,(mapcar #'(lambda (q)
			       `(make-tower .
					    ,(mapcar #'(lambda (q)
							       `(quote ,q))
						     q)))
		     towers)))

(defmacro initial towers
	  `(make-sit-plan
	    (make-structure
	     .,(mapcar #'(lambda (q)
				 `(make-tower .
					      ,(mapcar #'(lambda (q)
								 `(quote ,q))
						       q)))
		       towers))
	    ()))
(defun construct (s structure)
       (terpri)(terpri)
       (princ "Initial Situation")(terpri)
       (mapc #'(lambda (tower)
		       (print tower))
	     (situation s))
       (terpri)(terpri)
       (princ "Plan")(terpri)
       (mapc #'(lambda (step)
		       (princ "Put ")
		       (princ (block step))
		       (princ " on ")
		       (princ (location step))
		       (terpri))
	     (reverse (plan (build structure s))))
       (terpri)
       (princ "Final Situation")(terpri)
       (mapc #'(lambda (tower)
		       (print tower))
	     structure)
       (terpri)
       t)

(defun build (structure s)
       (cond ((empty-structure structure)
	      s)
	     (t (build (other-towers structure)
		       (build1 
			(reverse-tower (first-tower structure)) 
			s)))))

(defun build1 (rtower s)
       (let ((new-rtower (bottom-blocks rtower))
	     (location (top-block rtower)))
       (cond ((empty-tower new-rtower)
	      s)
	     (t (build1  new-rtower
			(move (top-block new-rtower) location s))))))

(defun move (block location s)
       (cond ((on block location (situation s))
	      s)
	     (t (immove block
			location
			(clear block (clear location s))))))

(defun immove (block location s)
       (make-sit-plan
	(update
	 (situation s)
	 (make-step block location))
	(add-plan (make-step block location) 
		  s)))

(defun clear (block s)
       (cond ((tablep block)
	      s)
	     (t (clear1 block (find block (situation s)) s))))

(defun update1 (s1 step)
       (cond
	((empty-situation s1) 
	 s1)
	((eq (top-block (first-tower s1)) (block step))
	 (add-tower (bottom-blocks (first-tower s1))
		    (update1 (other-towers s1) step)))
	((eq (top-block (first-tower s1)) (location step))
	 (add-tower
	  (add-block (block step) (first-tower s1))
	  (update1 (other-towers s1) (make-step (block step) 'table))))
	(t
	 (add-tower
	  (first-tower s1)
	  (update1 (other-towers s1) step))))))))))

(defun update (s1 step)
       (update2 
	(cond ((tablep (location step))
	       (add-tower
		(make-step (block step) 'table)
		(update1 s1 (make-step (block step) 'table))))
	      (t (update1 s1 step)))))

(defun update2 (s1)
       (cond ((empty-situation s1) nil)
	     ((table-only (first-tower s1)) 
	      (update2 (other-towers s1)))
	     (t (add-tower (first-tower s1)
			   (update2 (other-towers s1))))))

(defun find (b s1) 
 (do ((s s1 (other-towers s)))
     ((empty-situation s) ())
     (cond ((memq b (car s))
	    (return (car s))))))

(defun clear1 (b tower s)
       (cond ((eq b (top-block tower))
	      s)
	     (t (clear1 b (bottom-blocks tower) 
			(immove (top-block tower) 'table s)))))

(defun on (a b s1) (on1 a b (find a s1)))

(defun on1 (a b tower)
       (cond ((empty-tower tower) ())
	     ((empty-tower (bottom-blocks tower)) ())
	     ((and (eq (top-block tower) a)
		   (eq (top-block (bottom-blocks tower)) b))
	      t)
	     (t (on1 a b (bottom-blocks tower)))))))
(fasload block2)
(construct (initial (a)(b)(c))(goal (a b c))))

Initial Situation
(A TABLE) 
(B TABLE) 
(C TABLE) 
Plan
Put B on C
Put A on B
Final Situation
(A B C TABLE) 
T 

(construct
 (initial (a b c) (d e) (f))
 (goal (a b c d f) (e)))

Initial Situation
(A B C TABLE) 
(D E TABLE) 
(F TABLE) 
Plan
Put D on F
Put A on TABLE
Put B on TABLE
Put C on D
Put B on C
Put A on B
Final Situation
(A B C D F TABLE) 
(E TABLE) 
T 

(construct
 (initial (a b c)(d e)(f))
 (goal (c b)(a d e)(f)))

Initial Situation
(A B C TABLE) 
(D E TABLE) 
(F TABLE) 
Plan
Put A on TABLE
Put B on TABLE
Put C on B
Put A on D
Final Situation
(C B TABLE) 
(A D E TABLE) 
(F TABLE) 
T 

(construct
 (initial (c a) (b))
 (goal (a b c)))

Initial Situation
(C A TABLE) 
(B TABLE) 
Plan
Put C on TABLE
Put B on C
Put A on B
Final Situation
(A B C TABLE) 
T